!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright 2000-2024 CP2K developers group <https://cp2k.org>                                   !
!                                                                                                  !
!   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
!--------------------------------------------------------------------------------------------------!

! **************************************************************************************************
!> \brief Module that contains the routines for error handling
!> \author Ole Schuett
! **************************************************************************************************
MODULE cp_error_handling
   USE base_hooks,                      ONLY: cp_abort_hook,&
                                              cp_hint_hook,&
                                              cp_warn_hook
   USE cp_log_handling,                 ONLY: cp_logger_get_default_io_unit
   USE kinds,                           ONLY: dp
   USE machine,                         ONLY: default_output_unit,&
                                              m_flush,&
                                              m_walltime
   USE message_passing,                 ONLY: mp_abort
   USE print_messages,                  ONLY: print_message
   USE timings,                         ONLY: print_stack

!$ USE OMP_LIB, ONLY: omp_get_thread_num

   IMPLICIT NONE
   PRIVATE

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_error_handling'

   !API public routines
   PUBLIC :: cp_error_handling_setup

   !API (via pointer assignment to hook, PR67982, not meant to be called directly)
   PUBLIC :: cp_abort_handler, cp_warn_handler, cp_hint_handler

   INTEGER, PUBLIC, SAVE :: warning_counter = 0

CONTAINS

! **************************************************************************************************
!> \brief Registers handlers with base_hooks.F
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_error_handling_setup()
      cp_abort_hook => cp_abort_handler
      cp_warn_hook => cp_warn_handler
      cp_hint_hook => cp_hint_handler
   END SUBROUTINE cp_error_handling_setup

! **************************************************************************************************
!> \brief Abort program with error message
!> \param location ...
!> \param message ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_abort_handler(location, message)
      CHARACTER(len=*), INTENT(in)                       :: location, message

      INTEGER                                            :: unit_nr

      CALL delay_non_master() ! cleaner output if all ranks abort simultaneously

      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr <= 0) &
         unit_nr = default_output_unit ! fall back to stdout

      CALL print_abort_message(message, location, unit_nr)
      CALL print_stack(unit_nr)
      FLUSH (unit_nr)  ! ignore &GLOBAL / FLUSH_SHOULD_FLUSH

      CALL mp_abort()
   END SUBROUTINE cp_abort_handler

! **************************************************************************************************
!> \brief Signal a warning
!> \param location ...
!> \param message ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_warn_handler(location, message)
      CHARACTER(len=*), INTENT(in)                       :: location, message

      INTEGER                                            :: unit_nr

!$OMP MASTER
      warning_counter = warning_counter + 1
!$OMP END MASTER

      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr > 0) THEN
         CALL print_message("WARNING in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
         CALL m_flush(unit_nr)
      END IF
   END SUBROUTINE cp_warn_handler

! **************************************************************************************************
!> \brief Signal a hint
!> \param location ...
!> \param message ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_hint_handler(location, message)
      CHARACTER(len=*), INTENT(in)                       :: location, message

      INTEGER                                            :: unit_nr

      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr > 0) THEN
         CALL print_message("HINT in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
         CALL m_flush(unit_nr)
      END IF
   END SUBROUTINE cp_hint_handler

! **************************************************************************************************
!> \brief Delay non-master ranks/threads, used by cp_abort_handler()
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE delay_non_master()
      INTEGER                                            :: unit_nr
      REAL(KIND=dp)                                      :: t1, wait_time

      wait_time = 0.0_dp

      ! we (ab)use the logger to determine the first MPI rank
      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr <= 0) &
         wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second.

!$    IF (omp_get_thread_num() /= 0) &
!$       wait_time = wait_time + 1.0_dp ! master threads gets another second

      ! sleep
      IF (wait_time > 0.0_dp) THEN
         t1 = m_walltime()
         DO
            IF (m_walltime() - t1 > wait_time .OR. t1 < 0) EXIT
         END DO
      END IF

   END SUBROUTINE delay_non_master

! **************************************************************************************************
!> \brief Prints a nicely formatted abort message box
!> \param message ...
!> \param location ...
!> \param output_unit ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE print_abort_message(message, location, output_unit)
      CHARACTER(LEN=*), INTENT(IN)                       :: message, location
      INTEGER, INTENT(IN)                                :: output_unit

      INTEGER, PARAMETER :: img_height = 8, img_width = 9, screen_width = 80, &
         txt_width = screen_width - img_width - 5
      CHARACTER(LEN=img_width), DIMENSION(img_height), PARAMETER :: img = ["   ___   ", "  /   \  "&
         , " [ABORT] ", "  \___/  ", "    |    ", "  O/|    ", " /| |    ", " / \     "]

      CHARACTER(LEN=screen_width)                        :: msg_line
      INTEGER                                            :: a, b, c, fill, i, img_start, indent, &
                                                            msg_height, msg_start

! count message lines

      a = 1; b = -1; msg_height = 0
      DO WHILE (b < LEN_TRIM(message))
         b = next_linebreak(message, a, txt_width)
         a = b + 1
         msg_height = msg_height + 1
      END DO

      ! calculate message and image starting lines
      IF (img_height > msg_height) THEN
         msg_start = (img_height - msg_height)/2 + 1
         img_start = 1
      ELSE
         msg_start = 1
         img_start = msg_height - img_height + 2
      END IF

      ! print empty line
      WRITE (UNIT=output_unit, FMT="(A)") ""

      ! print opening line
      WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)

      ! print body
      a = 1; b = -1; c = 1
      DO i = 1, MAX(img_height - 1, msg_height)
         WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
         IF (i < img_start) THEN
            WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", img_width)
         ELSE
            WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
            c = c + 1
         END IF
         IF (i < msg_start) THEN
            WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", txt_width + 2)
         ELSE
            b = next_linebreak(message, a, txt_width)
            msg_line = message(a:b)
            a = b + 1
            fill = (txt_width - LEN_TRIM(msg_line))/2 + 1
            indent = txt_width - LEN_TRIM(msg_line) - fill + 2
            WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
            WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(msg_line)
            WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", fill)
         END IF
         WRITE (UNIT=output_unit, FMT="(A)", advance='yes') "*"
      END DO

      ! print location line
      WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
      WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
      indent = txt_width - LEN_TRIM(location) + 1
      WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
      WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(location)
      WRITE (UNIT=output_unit, FMT="(A)", advance='yes') " *"

      ! print closing line
      WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)

      ! print empty line
      WRITE (UNIT=output_unit, FMT="(A)") ""

   END SUBROUTINE print_abort_message

! **************************************************************************************************
!> \brief Helper routine for print_abort_message()
!> \param message ...
!> \param pos ...
!> \param rowlen ...
!> \return ...
!> \author Ole Schuett
! **************************************************************************************************
   FUNCTION next_linebreak(message, pos, rowlen) RESULT(ibreak)
      CHARACTER(LEN=*), INTENT(IN)                       :: message
      INTEGER, INTENT(IN)                                :: pos, rowlen
      INTEGER                                            :: ibreak

      INTEGER                                            :: i, n

      n = LEN_TRIM(message)
      IF (n - pos <= rowlen) THEN
         ibreak = n ! remaining message shorter than line
      ELSE
         i = INDEX(message(pos + 1:pos + 1 + rowlen), " ", BACK=.TRUE.)
         IF (i == 0) THEN
            ibreak = pos + rowlen - 1 ! no space found, break mid-word
         ELSE
            ibreak = pos + i ! break at space closest to rowlen
         END IF
      END IF
   END FUNCTION next_linebreak

END MODULE cp_error_handling
